home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 7: Sunsite / Linux Cubed Series 7 - Sunsite Vol 1.iso / system / shells / scsh-0.4 / scsh-0 / scsh-0.4.2 / bcomp / interface.scm < prev    next >
Text File  |  1995-10-13  |  2KB  |  89 lines
  1. ; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees.  See file COPYING.
  2.  
  3.  
  4. ; Interfaces
  5.  
  6. (define-record-type interface :interface
  7.   (really-make-interface ref walk clients name)
  8.   interface?
  9.   (ref ref-method)
  10.   (walk walk-method)
  11.   (clients interface-clients)
  12.   (name interface-name set-interface-name!))
  13.  
  14. (define-record-discloser :interface
  15.   (lambda (int) (list 'interface (interface-name int))))
  16.  
  17.  
  18. (define (interface-ref int name)
  19.   ((ref-method int) name))
  20.  
  21. (define (for-each-declaration proc int)
  22.   ((walk-method int) proc))
  23.  
  24. (define (note-reference-to-interface! int thing)
  25.   (let ((pop (interface-clients int)))
  26.     (if pop
  27.     (add-to-population! thing pop)
  28.     ;; If it's compound, we really ought to descend into its components
  29.     )))
  30.  
  31. ; If name is #f, then the interface is anonymous, so we don't need to
  32. ; make a population.
  33.  
  34. (define (make-interface ref walk name)
  35.   (really-make-interface ref walk
  36.              (make-population)
  37.              name))
  38.  
  39.  
  40. ; Simple interfaces (export (name type) ...)
  41.  
  42. (define (make-simple-interface name items)
  43.   (let ((table (make-table name-hash)))
  44.     (for-each (lambda (item)
  45.         (if (pair? item)
  46.             (let ((name (car item))
  47.               (type (cadr item)))
  48.               (if (or (null? name) (pair? name))
  49.               ;; Allow ((name1 name2 ...) type)
  50.               (for-each (lambda (name)
  51.                       (table-set! table name type))
  52.                     name)
  53.               (table-set! table name type)))
  54.             (table-set! table item undeclared-type)))
  55.           items)
  56.     (make-table-immutable! table)
  57.     (really-make-simple-interface table name)))
  58.  
  59. (define (really-make-simple-interface table name)
  60.   (make-interface (lambda (name) (table-ref table name))
  61.           (lambda (proc) (table-walk proc table))
  62.           name))
  63.  
  64.  
  65. ; Compoune interfaces
  66.  
  67. (define (make-compound-interface name . ints)
  68.   (let ((int
  69.      (make-interface (lambda (name)
  70.                (let loop ((ints ints))
  71.                  (if (null? ints)
  72.                  #f
  73.                  (or (interface-ref (car ints) name)
  74.                      (loop (cdr ints))))))
  75.              (lambda (proc)
  76.                (for-each (lambda (int)
  77.                        (for-each-declaration proc int))
  78.                      ints))
  79.              name)))
  80.     (for-each (lambda (i)
  81.         (note-reference-to-interface! i int))
  82.           ints)
  83.     int))
  84.  
  85.  
  86. (define (note-interface-name! int name)
  87.   (if (and name (not (interface-name int)))
  88.       (set-interface-name! int name)))
  89.